home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / FORTH / TEXTEDIT
Text File  |  1988-07-03  |  8KB  |  172 lines
  1. ( text edit example for Pocket Forth 1.4  16:15:59  7/1/88 )
  2. forget task : task ;  decimal
  3.  
  4. ( text edit record handle )
  5. 2variable TERECORD  ( pronounced "terra chord" )
  6. : TEH ( -- dhandle ) terecord 2@ ;  ( the TE record handle )
  7.  
  8. ( te toolbox routines )
  9. : TENEW ( -- ) ( initialize the TE record )
  10.     0 0 2>r  ( room for result from toolbox function )
  11.     4 +md a>r  ( push dest rect address to rstack )
  12.     4 +md a>r  (  "   view  "     "     "    "    )
  13.     ,$ A9D2  2r>  ( _TENew then pop handle from rstack )
  14.     terecord 2! ;  ( store the handle away for later )
  15. : TESETTEXT ( addr len -- ) ( set text to string from stack )
  16.     swap a>r  ( push string address to rstack )
  17.     s>d 2>r  ( push 32 bit string length to rstack )
  18.     teh 2>r  ( push the terecord's handle to rstack )
  19.     ,$ A9CF ;  ( _TESetText )
  20. : TEGETTEXT ( -- dhandle ) ( get a handle to the text )
  21.     0 0 2>r  ( room for the text handle )
  22.     teh 2>r  ( push the terecord's handle to rstack )
  23.     ,$ A9CB 2r> ;  ( _TEGetText, pop handle from rstack )
  24. : TELENGTH ( -- n ) ( get the length of the text )
  25.     teh dl@  ( get pointer to the text )
  26.     60 s>d d+  ( add teLength offset to pointer )
  27.     l@ ;  ( fetch length value )
  28. : TECLICK ( -- ) ( handle a click in the TE's rect )
  29.     @mouse 2>r  ( push the _current_ mouse position to rstack )
  30.     0 >r  ( not an extended click )
  31.     teh 2>r  ( push the terecord's handle to rstack )
  32.     ,$ A9D4 ;  ( _TEClick )
  33. : TEKEY ( c -- ) ( handle a character from the stack )
  34.     >r  ( push the character to the rstack )
  35.     teh 2>r ,$ A9DC ;  ( push handle _TEKey )
  36. : TEUPDATE ( -- ) ( draw the editable text )
  37.     4 +md a>r ( push the view rect's address to rstack )
  38.     teh 2>r  ,$ A9D3 ;  ( push handle _TEUpdate )
  39. : TEACTIVATE ( -- ) ( show selection, etc. )
  40.     teh 2>r  ,$ A9D8 ;  ( push handle _TEActivate )
  41. : TEDEACTIVATE ( -- ) ( hide selection, etc. )
  42.     teh 2>r  ,$ A9D9 ;  ( push handle _TEActivate )
  43. : TEIDLE ( -- ) ( blink the cursor )
  44.     teh 2>r  ,$ A9DA ;  ( push handle _TEIdle )
  45. : TECUT ( -- ) teh 2>r ,$ A9D6 ;  ( push handle _TECut )
  46. : TECOPY ( -- ) teh 2>r ,$ A9D5 ;  ( push handle _TECopy )
  47. : TEPASTE ( -- ) teh 2>r ,$ A9DB ;  ( push handle _TEPaste )
  48. : TEDISPOSE ( -- ) teh 2>r ,$ A9CD ;  ( push handle _TEDispose )
  49.  
  50. ( private te scrap to clipboard conversion )
  51. : "TEXT" ( -- d'TEXT' ) [ 22612 21573 dliteral ] ; macro
  52. : TEFROMSCRAP ( -- ) ( move clipboard contents to TE scrap )
  53.     0 0 2>r  ( room on rstack for toolbox function result )
  54.     2740 0 dl@ 2>r  ( push TEScrpHandle to rstack )
  55.     "text" 2>r  ( scrap type identifier )
  56.     here a>r  ( here is used as a temporary variable )
  57.       ,$ A9FD  ( _GetScrap )
  58.     2r> 0< IF  ( just test the high byte )
  59.       drop beep  ( drop error code & beep )
  60.     ELSE  2736 0 l!  THEN ;  ( set TEScrpLength )
  61. : TETOSCRAP ( -- ) ( move TE scrap to clipboard )
  62.     0 0 2>r  ( room on rstack for toolbox function result )
  63.      ,$ A9FC  ( _ZeroScrap )
  64.     2736 0 l@ 0 2>r  ( push TEScrpLength to rstack )
  65.     "text" 2>r  ( scrap type identifier )
  66.     2740 0 dl@ dl@ 2>r  ( double dereference TEScrpHandle )
  67.       ,$ A9FE  ( _PutScrap )
  68.     2r> + IF beep THEN ;  ( beep if error )
  69.  
  70. ( activate and edit menu handlers )
  71. : MYACT ( f -- ) IF teactivate ELSE tedeactivate THEN ;
  72. : EDITMENU ( n -- addr ) ( item to address, undo is 0 )
  73.     18 +md @ 2+ @ swap 2* + ;
  74. : CUT ( -- ) tecut tetoscrap ;
  75. : COPY ( -- ) tecopy tetoscrap ;
  76. : PASTE ( -- ) tefromscrap tepaste ;
  77.  
  78. ( string compilation )
  79. : EVEN ( n -- n' ) dup 2 mod + ;  ( round n up to an even number )
  80. : ," ( -- ) ( compile a quoted string from input stream )
  81.     34 word here c@ 1+ even allot ; immediate
  82.  
  83. ( a string )
  84. create INTRO ( -- addr ) ( some text to edit )
  85.     ," This is editable text.  Press Enter to quit."
  86.  
  87. : NOCURSOR ( -- ) ( don't draw the little line cursor )
  88.     20085 14 +md @ ! ;  ( replace cursor routine with RTS )
  89. : !EDIT ( -- ) ( set input routines to edit text )
  90.     nocursor page  ( prepare the window )
  91.     [ ' teclick literal ] 16 +md !  ( set button handler )
  92.     [ ' teidle literal ] 20 +md !  ( set idle handler )
  93.     [ ' teupdate literal ] 14 +md !  ( set update handler )
  94.     [ ' myact literal ] 12 +md !  ( set activate handler )
  95.     [ ' cut literal ] 2 editmenu !  ( set cut )
  96.     [ ' copy literal ] 3 editmenu !  ( set copy )
  97.     [ ' paste literal ] 4 editmenu !  ( set paste )
  98.     intro count tesettext ;  ( set the initial text to edit )
  99. : !INTERPRET ( -- ) ( reset the interpreter handlers )
  100.     [ ' beep literal ] 16 +md !  ( reset button handler )
  101.     [ ' null literal ] 20 +md !  ( reset idle handler )
  102.     [ 14 +md @ literal ] 14 +md !  ( reset update )
  103.     [ ' drop literal ] 12 +md !  ( reset activate )
  104.     [ ' beep literal ] 2 editmenu !  ( reset cut )
  105.     [ ' beep literal ] 3 editmenu !  ( reset copy )
  106.     [ 4 editmenu @ literal ] 4 editmenu !  ( reset paste )
  107.     [ 14 +md @ @ literal ] 14 +md @ ! ;  ( reset cursor )
  108.  
  109. ( This part is from the Release 4 file "DataFiles". )
  110. variable FCB 78 allot  ( the file control block )
  111. : +FCB ( offset -- addr ) fcb + ;  ( offset into fcb )
  112. : 0FCB ( -- ) fcb 80 0 fill ;  ( clear the fcb )
  113. : FTRAP ( -- ) fcb >abs  ,$ 205E ;  ( movea.l [ps]+,a0 )
  114. : CLOSE ( -- ) ftrap ,$ A001  ftrap ,$ A013 ;  ( close & flush )
  115. : ?DERROR ( -- ) ( nothing if no error, quit if disk error )
  116.      16 +fcb @ ?dup IF  ( if result not zero )
  117.       ." DiskError" .  close  abort THEN ;  ( report & abort )
  118. : !SIZE ( bytes -- ) 38 +fcb ! ;  ( set bytes-to-read or write )
  119. : !NAME ( name.addr -- ) >abs  0fcb  18 +fcb  2! ;  ( set name )
  120. : !TYPE ( dtype -- ) 32 +fcb 2!  ( set the file type )
  121.     ftrap ,$ A00D ?derror ;  ( _SetFileInfo )
  122. : NEW ( name.addr -- ) ( create a file, or replace an existing one  )
  123.     !name  ( set the file name )
  124.     ftrap ,$ A008  ( _Create )
  125.     16 +fcb @ -48 = 0= IF  ( This line has been added to ... )
  126.       ?derror THEN ;  ( ... ignore duplicate file name errors. )
  127. : OPEN ( -- ) ftrap ,$ A000  ?derror ;  ( _Open the file )
  128. : WRITE ( dabs.addr -- ) ( write to file from absolute address )
  129.     32 +fcb 2!  ( set write buffer pointer )
  130.     ftrap ,$ A003  ?derror ;  ( _Write )
  131.  
  132. create FILENAME ( -- name.addr ) ," Pocket Text"
  133. : SAVETEXT ( -- ) ( save the text to the file )
  134.     cr ." Saving text to file 'Pocket Text'."  ( inform )
  135.     filename new open ( create a new file and open it )
  136.       "text" !type  ( set file type to TEXT )
  137.       telength !size  ( set the number of bytes to write )
  138.       tegettext dl@ write  ( send the text to the file )
  139.     close ;  ( close the file )
  140. ( If an I/O error occurs, type:  !interpret tedispose  )
  141.  
  142. ( event record access / command key test )
  143. : +ERECORD ( offset -- dabs.addr ) ( access the DA's event record )
  144.     ,$ 2044  ( movea.l d4,a0 ) ( D4 has the parameter block address )
  145.     ,$ 2D28 ,$ 1C  ( move.l csParams{a0},-{ps} ) ( push event record address )
  146.     rot 0 d+ ;  ( double.offset + event record absolute address )
  147. : META ( -- n ) 14 +erecord l@ ;  ( get meta keys word )
  148. : ?CMD ( -- flag ) meta 256 and ;  ( true if clover key is down )
  149. : COMMANDKEYS ( c -- ) ( do command key handlers )
  150.     >r  ( hold the character on the return stack )
  151.     r 120 = IF cut ELSE  ( if character = x then cut )
  152.       r 99 = IF copy ELSE  ( if character = c then copy )
  153.         r 118 = IF paste THEN  ( if character = v then paste )
  154.     THEN THEN  r> drop ;  ( pop and drop the character )
  155.  
  156. : EDIT ( -- ) ( run the demo )
  157.     tenew  ( create the text edit record )
  158.       !edit ( set the text edit event handlers )
  159.       teupdate  ( draw the existing text )
  160.       teactivate  ( start editing text )
  161.         BEGIN
  162.           key dup  ( get a key )
  163.         3 > WHILE  ( until "enter" is pressed )
  164.           ?cmd IF  ( check cmd key )
  165.             commandkeys ELSE tekey THEN  ( handle key presses )
  166.         REPEAT drop
  167.       tedeactivate  ( turn off text editing )
  168.       !interpret  ( reset the standard event handlers )
  169.       savetext  ( save the text to a file )
  170.     tedispose ;  ( get rid of the text edit record )
  171. edit
  172.